Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue39/Clinic/AddItem2U2.PAS

Pascal/Delphi Source File | 1998-07-16 | 5.9 KB | 159 lines

unit AddItem2U2;

interface

uses
  SysUtils;

type
  EShellError = class(Exception);

procedure CreateShortCut(const Folder, Description, Path, Arguments,
  Directory, IconPath: String; IconIndex: Integer; ShowMin: Boolean);

implementation

{$ifdef Ver90} { Delphi 2.0x }
  {$define DelphiLessThan3}
{$endif}
{$ifdef Ver93} { C++ Builder 1.0x }
  {$define DelphiLessThan3}
{$endif}

uses
{$ifdef DelphiLessThan3}
  Ole2,
{$else}
  ShlObj, ActiveX, ComObj,
{$endif}
  Windows, Forms, Dialogs, ShellAPI;

{$ifdef DelphiLessThan3}
type
  TSHItemID = packed record           { mkid }
    cb: Word;                         { Size of the ID (including cb itself) }
    abID: array[0..0] of Byte;        { The item ID (variable length) }
  end;

  PItemIDList = ^TItemIDList;
  TItemIDList = packed record
    mkid: TSHItemID;
  end;

  IShellLink = class(IUnknown)
  public
    function GetPath(pszFile: PChar;  cchMaxPath: Integer;  var pfd: TWin32FindData; fFlags: Integer): HResult;  virtual;  stdcall;  abstract;
    function GetIDList(var ppidl: PItemIDList): HResult;  virtual;  stdcall;  abstract;
    function SetIDList(var ppidl: PItemIDList): HResult;  virtual;  stdcall;  abstract;
    function GetDescription(pszName: PChar;  cchMaxName: Integer): HResult; virtual;  stdcall;  abstract;
    function SetDescription(pszName: PChar): HResult;  virtual;  stdcall;  abstract;
    function GetWorkingDirectory(pszDir: PChar;  cchMaxPath: Integer): HResult;  virtual;  stdcall;  abstract;
    function SetWorkingDirectory(pszDir: PChar): HResult;  virtual;  stdcall;  abstract;
    function GetArguments(pszArgs: PChar;  cchMaxPath: Integer): HResult; virtual;  stdcall;  abstract;
    function SetArguments(pszArgs: PChar): HResult;  virtual;  stdcall;  abstract;
    function GetHotkey(var pwHotKey: Word): HResult;  virtual;  stdcall;  abstract;
    function SetHotkey(pwHotKey: Word): HResult;  virtual;  stdcall;  abstract;
    function GetShowCmd(var piShowCmd: Integer): HResult;  virtual;  stdcall;  abstract;
    function SetShowCmd(piShowCmd: Integer): HResult;  virtual;  stdcall;  abstract;
    function GetIconLocation(pszIconPath: PChar;  cchIconPath: Integer;  var piIcon: Integer): HResult; virtual;  stdcall;  abstract;
    function SetIconLocation(pszIconPath: PChar;  piIcon: Integer): HResult; virtual;  stdcall;  abstract;
    function SetRelativePath(pszPathRel: PChar;  dsReserved: Integer): HResult; virtual;  stdcall;  abstract;
    function Resolve(fFlags: Integer): HResult;  virtual;  stdcall;  abstract;
    function SetPath(pszFile: PChar): HResult;  virtual;  stdcall;  abstract;
  end;

function SHGetSpecialFolderLocation(hwndOwner: HWND; nFolder: Integer;
  var ppidl: PItemIDList): HResult; stdcall; external 'Shell32.Dll';
function SHGetPathFromIDList(pidl: PItemIDList; pszPath: PChar): BOOL; stdcall; external 'Shell32.Dll';
function SHGetMalloc(var ppMalloc: IMalloc): HResult; stdcall; external 'Shell32.Dll';

const
  CLSID_ShellLink: TGUID = (
    D1:$00021401; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));
  IID_ShellLink: TGUID = (
    D1:$000214EE; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));

  CSIDL_PROGRAMS = 2;
{$endif}

function Succeeded(Res: HResult): Boolean;
begin
  Result := Res and $80000000 = 0;
end;

procedure OleCheck(Result: HResult);
var
  S: string;
begin
  if not Succeeded(Result) then
  begin
    S := SysErrorMessage(Result);
    if S = '' then
      FmtStr(S, 'OLE error %.8x', [Result]);
    raise EShellError(S)
  end
end;

function GetLocation(Folder: DWord): String;
var
  PIDList: PItemIDList;
  Buf: array[0..MAX_PATH] of Char;
  Malloc: IMalloc;
begin
  if SHGetSpecialFolderLocation(Application.Handle, Folder, PIDList) <> NOERROR then
    raise EShellError.Create('Cannot find desktop folder');
  if SHGetPathFromIDList(PIDList, Buf) then
    Result := StrPas(Buf);
  if (SHGetMalloc(Malloc) = NOERROR) then
    Malloc.Free(PIDList)
end;

procedure CreateShortCut(const Folder, Description, Path, Arguments,
  Directory, IconPath: String; IconIndex: Integer; ShowMin: Boolean);
var
  ShellLink: IShellLink;
  PersistFile: IPersistFile;
  LinkFile: array [0..MAX_PATH] of WideChar;
  FolderPath, ShortCutPath: String;
const
  ShowCmd: array[Boolean] of Integer = (sw_ShowNormal, sw_Minimize);
begin
  FolderPath := GetLocation(CSIDL_PROGRAMS) + '\' + Folder;
  { Unlike MkDir, this doesn't raise an exception if it fails }
  CreateDirectory(PChar(FolderPath), nil);
  { To display the folder when creating shortcuts, uncomment this line }
  { ShellExecute(Application.Handle, nil, PChar(FolderPath), nil, nil, sw_ShowNormal); }
  {$ifdef DelphiLessThan3}
  if CoInitialize(nil) > 0 then
    try
      OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IID_ShellLink, ShellLink));
      OleCheck(ShellLink.QueryInterface(IID_IPersistFile, PersistFile));
  {$else}
      ShellLink := CreateComObject(CLSID_ShellLink) as IShellLink;
      PersistFile := ShellLink as IPersistFile;
  {$endif}
      ShellLink.SetDescription(PChar(Description));
      ShellLink.SetPath(PChar(Path));
      ShellLink.SetArguments(PChar(Arguments));
      ShellLink.SetWorkingDirectory(PChar(Directory));
      ShellLink.SetIconLocation(PChar(IconPath), IconIndex);
      ShellLink.SetShowCmd(ShowCmd[ShowMin]);

      ShortCutPath := FolderPath + '\' + Description;
      if UpperCase(ExtractFileExt(ShortcutPath)) <> '.LNK' then
        ShortCutPath := ShortCutPath + '.LNK';
      { In Delphi 3, we could rewrite the following two statements as: }
      { OleCheck(PersistFile.Save(PWideChar(WideString(ShortCutPath)), True)); }
      StringToWideChar(ShortCutPath, LinkFile, SizeOf(LinkFile));
      OleCheck(PersistFile.Save(LinkFile, True));
    {$ifdef DelphiLessThan3}
      PersistFile.Release;
      ShellLink.Release;
    finally
      CoUninitialize;
    end;
    {$endif}
end;

end.